home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_FILEH.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-02-24  |  10.5 KB  |  417 lines
  1. unit GS_FileH;
  2. {------------------------------------------------------------------------------
  3.                                   File Handler
  4.  
  5.        Copyright (c)  Richard F. Griffin
  6.  
  7.        20 February 1992
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles all untyped files.  Also provides file directory
  14.        search and selection.
  15.  
  16.        Since all calls come through here for untyped files, this is a point
  17.        to trap the calls in the future for shared file handling.
  18.  
  19.        Changes:
  20.  
  21.           19 Feb 92 - Deleted buffering to speed indexed retrievals.
  22.  
  23. ------------------------------------------------------------------------------}
  24.  
  25. interface
  26. {$d-}
  27.  
  28. uses
  29.    CRT,
  30.    Dos,
  31.    GS_Strng,
  32.    GS_Error;
  33.  
  34. var
  35.    GS_FileDrvTab      : array[0..127] of char;
  36.    GS_FileDrvCnt      : byte;
  37.  
  38.    BRCmd,
  39.    BWCmd,
  40.    IOAsk,
  41.    IORed,
  42.    IOWri,
  43.    IOPhy  : word;
  44.  
  45. Procedure GS_FileAssign(var dF : file; Fname : string);
  46. Procedure GS_FileClose(var dF : file);
  47. Procedure GS_FileErase(var dF : file);
  48. Function  GS_FileExists(var dF : file; Fname : string) : boolean;
  49. Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
  50.                        var RtnRslt : word);
  51. Procedure GS_FileRename(var dF : file; FName : string);
  52. Procedure GS_FileReset(var dF : file; len : longint);
  53. Procedure GS_FileRewrite(var dF : file; len : longint);
  54. Function  GS_FileSize(var dF : file) : longint;
  55. Procedure GS_FileTruncate(var dF : file; loc : longint);
  56. Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
  57.                        var RtnRslt : word);
  58. function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
  59.                                                                    : string;
  60.  
  61. implementation
  62.  
  63. uses
  64.    GS_Pick,
  65.    GS_Winfc;
  66.  
  67. type
  68.    BufrRec = record
  69.                 Size   : word;        {Size of buffer}
  70.                 CntByt : word;        {Bytes stores in buffer}
  71.                 Posn   : longint;     {Beginning byte of file in buffer}
  72.                 FPosn  : longint;     {Last byte read + 1 in buffer}
  73.                 BufPtr : Pointer;
  74.              end;
  75.  
  76. var
  77.    Bufr  : BufrRec;
  78.    dbfErr : integer;
  79.    Blok,
  80.    TPosS,
  81.    TPosE  : longint;
  82.    StrFil : string[80];
  83.    istrue : boolean;
  84.  
  85.    cdriv   : byte;
  86.    tdrv    : byte;
  87.    regs    : Registers;
  88.  
  89.    ShoWin  : GS_Wind_Objt;
  90.  
  91. Procedure GS_FileAssign(var dF : file; Fname : string);
  92. var
  93.    dFa    : FileRec absolute dF;
  94. begin
  95.    Assign(df, FName);
  96.    Bufr.Posn  := -1;
  97.    Bufr.FPosn := 0;
  98.    Bufr.CntByt := 0;
  99.    Bufr.Size  := 0;
  100.    Bufr.BufPtr := nil;
  101.    move(Bufr, dFa.UserData, sizeof(Bufr));
  102. end;
  103.  
  104. Procedure GS_FileClose(var dF : file);
  105. var
  106.    dFa    : FileRec absolute dF;
  107. begin
  108.    Close(df);
  109. end;
  110.  
  111. Procedure GS_FileErase(var dF : file);
  112. begin
  113.    Erase(df);
  114. end;
  115.  
  116. Function  GS_FileExists(var dF : file; Fname : string) : boolean;
  117. begin
  118.    if (FName <> '') then
  119.    begin
  120.       {$I-}
  121.       Assign(dF, FName);
  122.       Reset(dF);
  123.       Close(dF);
  124.       {$I+}
  125.       GS_FileExists := (IOResult = 0);
  126.    end else GS_FileExists := false;
  127. end;
  128.  
  129. Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
  130.                       var RtnRslt : word);
  131. var
  132.    dFa    : FileRec absolute dF;
  133.    Result : word;
  134.    StrFil : string[80];
  135. begin
  136.    move(dFa.UserData, Bufr, sizeof(Bufr));
  137.    if blk = -1 then blk := succ(Bufr.Posn);
  138.    dbfErr := 0;
  139.    begin
  140.       (*$I-*) Seek(dF, blk); (*$I+*)
  141.       dbfErr := IOResult;
  142.    end;
  143.    IF dbfErr = 0 THEN               {If seek ok, read the record}
  144.    BEGIN
  145.       inc(BRCmd);
  146.       (*$I-*)
  147.       BlockRead(dF, dat, len, Result);
  148.       (*$I+*)
  149.       RtnRslt := Result;
  150.       dbfErr := IOResult;
  151.       if dbfErr = 0 then
  152.       begin
  153.          Bufr.Posn := blk + (len-1);
  154.          move(Bufr, dFa.UserData, sizeof(Bufr));
  155.       end;
  156.    end;
  157.    if dbfErr <> 0 then
  158.    begin
  159.       CnvAscToStr(dFa.Name,StrFil,64);
  160.       ShowError(dbfErr,StrFil);
  161.    end;
  162. end;
  163.  
  164. Procedure GS_FileRename(var dF : file; Fname : string);
  165. begin
  166.    Rename(df, FName);
  167. end;
  168.  
  169. Procedure GS_FileReset(var dF : file; len : longint);
  170. var
  171.    dFa    : FileRec absolute dF;
  172.    StrFil : string[80];
  173. begin
  174.    (*$I-*) Reset(dF, len); (*$I+*)
  175.    dbfErr := IOResult;
  176.    if dbfErr <> 0 then
  177.    begin
  178.       CnvAscToStr(dFa.Name,StrFil,64);
  179.       ShowError(dbfErr,StrFil);
  180.    end;
  181. end;
  182.  
  183. Procedure GS_FileRewrite(var dF : file; len : longint);
  184. var
  185.    dFa    : FileRec absolute dF;
  186.    StrFil : string[80];
  187. begin
  188.    (*$I-*) Rewrite(dF, len); (*$I+*)
  189.    dbfErr := IOResult;
  190.    if dbfErr <> 0 then
  191.    begin
  192.       CnvAscToStr(dFa.Name,StrFil,64);
  193.       ShowError(dbfErr,StrFil);
  194.    end;
  195. end;
  196.  
  197. Function GS_FileSize(var dF : file) : longint;
  198. begin
  199.    GS_FileSize := FileSize(df);
  200. end;
  201.  
  202.  
  203. Procedure GS_FileTruncate(var dF : file; loc : longint);
  204. var
  205.    dFa    : FileRec absolute dF;
  206. begin
  207.    move(dFa.UserData, Bufr, sizeof(Bufr));
  208.    if loc = -1 then loc := succ(Bufr.Posn);
  209.    dbfErr := 0;
  210.    (*$I-*) Seek(dF, loc); (*$I+*)
  211.    dbfErr := IOResult;
  212.    if dbfErr <> 0 then
  213.    begin
  214.       CnvAscToStr(dFa.Name,StrFil,64);
  215.       ShowError(dbfErr,StrFil);
  216.    end;
  217.    Truncate(df);
  218.    Bufr.Posn := loc;
  219.    move(Bufr, dFa.UserData, sizeof(Bufr));
  220. end;
  221.  
  222.  
  223. Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
  224.                        var RtnRslt : word);
  225. var
  226.    dFa    : FileRec absolute dF;
  227.    Result : word;
  228.    StrFil : string[80];
  229. begin
  230.    move(dFa.UserData, Bufr, sizeof(Bufr));
  231.    if blk = -1 then blk := succ(Bufr.Posn);
  232.    dbfErr := 0;
  233.    (*$I-*) Seek(dF, blk); (*$I+*)
  234.    dbfErr := IOResult;
  235.    IF dbfErr = 0 THEN               {If seek ok, read the record}
  236.    BEGIN
  237.       (*$I-*) BlockWrite(dF, dat, len, Result); (*$I+*)
  238.       RtnRslt := Result;
  239.       dbfErr := IOResult;
  240.       IF dbfErr = 0 THEN               {If seek ok, read the record}
  241.       BEGIN
  242.          Bufr.Posn := blk + (len-1);
  243.          move(Bufr, dFa.UserData, sizeof(Bufr));
  244.       end;
  245.    end;
  246.    if dbfErr <> 0 then
  247.    begin
  248.       CnvAscToStr(dFa.Name,StrFil,64);
  249.       ShowError(dbfErr,StrFil);
  250.    end;
  251. end;
  252.  
  253. function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
  254.                                                                   : string;
  255. var
  256.    DirInfo : SearchRec;
  257.    FilTabl : array[1..512] of string[12];
  258.    Labl    : string;
  259.    DirNow,
  260.    DirNam,
  261.    DirCur  : PathStr;
  262.    DSt     : DirStr;
  263.    NSt     : NameStr;
  264.    ESt     : ExtStr;
  265.    itms    : integer;
  266.    rfil    : integer;
  267.    rdir    : integer;
  268.    slct    : integer;
  269.    lctn    : integer;
  270.    wtx,
  271.    wbg,
  272.    wfg,
  273.    wti,
  274.    wbi     : byte;
  275.    wx1,
  276.    wy1,
  277.    wx2,
  278.    wy2     : integer;
  279.  
  280.   procedure MakeFileTable;
  281.   var
  282.      i : integer;
  283.      d : string;
  284.      v : char;
  285.      u : byte absolute v;
  286.      b : byte;
  287.    begin
  288.       itms := 0;
  289.       FindFirst(Labl, Archive, DirInfo);
  290.       while DosError = 0 do
  291.       begin
  292.          inc(itms);
  293.          FilTabl[itms] := DirInfo.Name;
  294.          FindNext(DirInfo);
  295.       end;
  296.       rfil := itms;
  297.       if itms > 0 then
  298.          GS_Pick_Item_Sort(FilTabl[1],sizeof(FilTabl[1]),itms,true);
  299.       if LookElseWhere then
  300.       begin
  301.          FindFirst('*.', Directory, DirInfo);
  302.          while DosError = 0 do
  303.          begin
  304.             if (DirInfo.Attr = directory) and (DirInfo.Name <> '.') then
  305.             begin
  306.                inc(itms);
  307.                for i := 1 to length(DirInfo.Name) do
  308.                begin
  309.                   v := DirInfo.Name[i];
  310.                   if v in ['A'..'Z'] then u := u + 32;
  311.                   DirInfo.Name[i] := v;
  312.                end;
  313.                FilTabl[itms] := DirInfo.Name+'\';
  314.             end;
  315.             FindNext(DirInfo);
  316.          end;
  317.          rdir := itms;
  318.          if itms-rfil > 0 then
  319.             GS_Pick_Item_Sort(FilTabl[succ(rfil)],sizeof(FilTabl[1]),
  320.                               itms-rfil,true);
  321.          for i := 0 to pred(GS_FileDrvCnt) do
  322.          begin
  323.             if GS_FileDrvTab[i] = 'P' then
  324.             begin
  325.                inc(itms);
  326.                FilTabl[itms] := chr(i+65)+':\';
  327.             end;
  328.          end;
  329.       end;
  330.    end;
  331.  
  332. begin
  333.    GS_Wind_GetWinSize(wx1,wy1,wx2,wy2);
  334.    if (wx2-wx1 < 16) or (wy2-wy1 < 7) then
  335.    begin
  336.       ShowError(777,'Window too small for file display');
  337.       GS_FileFindFiles := '';
  338.       exit;
  339.    end;
  340.    GS_Wind_GetColors(wtx,wbg,wfg,wti,wbi);
  341.    ShoWin.InitWin(wx1+1,wy1+1,wx1+15,wy2-3,wti,wbi,wfg,wtx,wbg,true,'',true);
  342.    GetDir(0,DirNow);
  343.    if pth <> '' then
  344.    begin
  345.       FSplit(pth, DSt, NSt, ESt);
  346.       DSt[0] := pred(DSt[0]);
  347.       (*$I-*) ChDir(DSt) (*$I+*);
  348.    end;
  349.    GetDir(0,DirNam);
  350.    DirCur := DirNam;
  351.    repeat
  352.       if DirNam[length(DirNam)] <> '\' then DirNam := DirNam + '\';
  353.       GoToXY(2,(wy2-wy1)-1);
  354.       Write('Dir = ',DirNam);
  355.       Labl := DirNam+fname;
  356.       MakeFileTable;
  357.       if itms > 0 then
  358.       begin
  359.          ShoWin.SetWin;
  360.          slct := GS_Pick_Row_Item(FilTabl, 13, itms, 1);
  361.          ShoWin.RelWin;
  362.          ClrScr;
  363.       end else slct := 0;
  364.       if slct > rfil then
  365.       begin
  366.          if slct > rdir then (*$I-*) ChDir(DirCur) (*$I+*);
  367.          DirNam := FilTabl[slct];
  368.          DirNam[0] := pred(DirNam[0]);
  369.          (*$I-*) ChDir(DirNam) (*$I+*);
  370.          GetDir(0,DirNam);
  371.          if slct > rdir then DirCur := DirNam;
  372.       end;
  373.       if (slct > 0) and (slct <= rfil) then
  374.          Labl := FilTabl[slct] else Labl := '';
  375.       lctn := pos('.',Labl);
  376.       if lctn > 0 then delete(Labl,lctn,4);
  377.    until slct <= rfil;
  378.    if DirNam[length(DirNam)] <> '\' then DirNam := DirNam + '\';
  379.    if Labl <> '' then GS_FileFindFiles := DirNam+Labl
  380.       else GS_FileFindFiles := '';
  381.    if slct = 0 then GS_FileFindFiles := '-';
  382.    ChDir(DirNow);
  383. end;
  384.  
  385.  
  386. begin
  387.    IOAsk := 0;
  388.    IOPhy := 0;
  389.    IORed := 0;
  390.    IOWri := 0;
  391.    BRCmd := 0;
  392.    BWCmd := 0;
  393.                     {Build Drive Table}
  394.    regs.ah := 25;
  395.    MsDos(regs);
  396.    cdriv := regs.al;
  397.    regs.dl := cdriv;
  398.    regs.ah := 14;
  399.    MsDos(regs);
  400.    GS_FileDrvCnt := regs.al;
  401.    tdrv := 0;
  402.    while tdrv < GS_FileDrvCnt do
  403.    begin
  404.       regs.dl := tdrv;
  405.       regs.ah := 14;
  406.       MsDos(regs);
  407.       regs.ah := 25;
  408.       MsDos(regs);
  409.       if tdrv = regs.al then GS_FileDrvTab[tdrv] := 'P'
  410.          else GS_FileDrvTab[tdrv] := ' ';
  411.       inc(tdrv);
  412.    end;
  413.    regs.dl := cdriv;
  414.    regs.ah := 14;
  415.    MsDos(regs);
  416. end.
  417.